Results

KableExtra

Example:

#Convert time series to a data frame
ap <- data.frame(passengers=as.matrix(AirPassengers), date=as.numeric(time(AirPassengers)))


# convert date field into separate years and months
ap_ym <- ap %>% mutate(year=year(date_decimal(date)),
                       month = round((date-floor(date))*12,0)+1) %>% 
  select(-2)

# subdivide passengers by year
ap_sp <- split(ap_ym$passengers,ap_ym$year)

# summarise passengers by year
ap_sum <- ap_ym %>% 
  group_by(year) %>% 
  summarise(min=min(passengers),
            ave=round(mean(passengers),0),
            max=max(passengers))

#Build data frame skeleton
ap_df <- data.frame(ap_sum,"Box_plot"="","Hist"="","Free_hist"="",
                    "poly"="", "line_l"="","line_p"="")

# Sparkline output
ap_df %>%
  kbl(booktabs = TRUE, caption = "Air Passengers 1949-1960") %>%
  kable_styling(position = "left",bootstrap_options = "striped",full_width = FALSE) %>% 
  column_spec(5,  image = spec_boxplot(ap_sp,col="lightblue")) %>% 
  column_spec(6,  image = spec_hist(ap_sp)) %>% 
  column_spec(7,  image = spec_hist(ap_sp,same_lim = FALSE,col="lightblue")) %>%  
  column_spec(8,  image = spec_plot(ap_sp,same_lim = FALSE,col="lightblue",polymin =ap_df$ave)) %>% 
  column_spec(9,  image = spec_plot(ap_sp,same_lim = FALSE,col="lightblue",type="l")) %>% 
  column_spec(10, image = spec_plot(ap_sp,same_lim = FALSE,col="lightblue",type ="p"))
Air Passengers 1949-1960
year min ave max Box_plot Hist Free_hist poly line_l line_p
1949 104 127 148
1950 114 140 170
1951 145 170 199
1952 171 197 242
1953 180 225 272
1954 188 239 302
1955 233 284 364
1956 271 328 413
1957 301 368 467
1958 310 381 505
1959 342 428 559
1960 390 476 622 
Speed <- cars$speed
Distance <- cars$dist
plot(Speed, Distance, panel.first = grid(8, 8),
     pch = 0, cex = 1.2, col = "blue")

plot(Speed, Distance,
     panel.first = lines(stats::lowess(Speed, Distance), lty = "dashed"),
     pch = 0, cex = 1.2, col = "blue")

## Show the different plot types
x <- 0:12
y <- sin(pi/5 * x)
op <- par(mfrow = c(3,3), mar = .1+ c(2,2,3,1))
for (tp in c("p","l","b",  "c","o","h",  "s","S","n")) {
  plot(y ~ x, type = tp, main = paste0("plot(*, type = \"", tp, "\")"))
  if(tp == "S") {
    lines(x, y, type = "s", col = "red", lty = 2)
    mtext("lines(*, type = \"s\", ...)", col = "red", cex = 0.8)
  }
}

par(op)
##--- Log-Log Plot  with  custom axes
lx <- seq(1, 5, length.out = 41)
yl <- expression(e^{-frac(1,2) * {log[10](x)}^2})
y <- exp(-.5*lx^2)
op <- par(mfrow = c(2,1), mar = par("mar")-c(1,0,2,0), mgp = c(2, .7, 0))
plot(10^lx, y, log = "xy", type = "l", col = "purple",
     main = "Log-Log plot", ylab = yl, xlab = "x")
plot(10^lx, y, log = "xy", type = "o", pch = ".", col = "forestgreen",
     main = "Log-Log plot with custom axes", ylab = yl, xlab = "x",
     axes = FALSE, frame.plot = TRUE)
my.at <- 10^(1:5)
axis(1, at = my.at, labels = formatC(my.at, format = "fg"))
e.y <- -5:-1 ; at.y <- 10^e.y
axis(2, at = at.y, col.axis = "red", las = 1,
     labels = as.expression(lapply(e.y, function(E) bquote(10^.(E)))))

par(op)

Circular Bar Charts

rm(list=ls())
library(tidyverse)

# Create dataset
data <- data.frame(
  individual=paste( "Mister ", seq(1,38), sep=""),
  group=as.factor(c( rep('OR\n(10)', 10), rep('WAMT\n(15)', 15), rep('CA\n(9)', 9), rep('Alaska\n(4)', 4))) ,
  value=sample( seq(10,100), 38, replace=T)
)

# Set a number of 'empty bar' to add at the end of each group
empty_bar <- 3
to_add <- data.frame( matrix(NA, empty_bar*nlevels(data$group), ncol(data)) )
colnames(to_add) <- colnames(data)
to_add$group <- rep(levels(data$group), each=empty_bar)
data <- rbind(data, to_add)
data <- data %>% arrange(group, value)
data$id <- seq(1, nrow(data))

# Get the name and the y position of each label
label_data <- data
number_of_bar <- nrow(label_data)
angle <- 90 - 360 * (label_data$id-0.5) /number_of_bar     # I substract 0.5 because the letter must have the angle of the center of the bars. Not extreme right(1) or extreme left (0)
label_data$hjust <- ifelse( angle < -90, 1, 0)
label_data$angle <- ifelse(angle < -90, angle+180, angle)

# prepare a data frame for base lines
base_data <- data %>% 
  group_by(group) %>% 
  summarize(start=min(id), end=max(id) - empty_bar) %>% 
  rowwise() %>% 
  mutate(title=mean(c(start, end)))

# prepare a data frame for grid (scales)
grid_data <- base_data
grid_data$end <- grid_data$end[ c( nrow(grid_data), 1:nrow(grid_data)-1)] + 1
grid_data$start <- grid_data$start - 1
grid_data <- grid_data[-1,]

#data = data %>% arrange(group, value)
# Make the plot
p <- ggplot(data, aes(x=as.factor(id), y=value, fill=group)) +       # Note that id is a factor. If x is numeric, there is some space between the first bar
  geom_bar(aes(x=as.factor(id), y=value, fill=group), stat="identity", alpha=0.5) +
  
  # Add a val=100/75/50/25 lines. I do it at the beginning to make sur barplots are OVER it.
  geom_segment(data=grid_data, aes(x = end, y = 80, xend = start, yend = 80), colour = "grey", alpha=1, size=0.3 , inherit.aes = FALSE ) +
  geom_segment(data=grid_data, aes(x = end, y = 60, xend = start, yend = 60), colour = "grey", alpha=1, size=0.3 , inherit.aes = FALSE ) +
  geom_segment(data=grid_data, aes(x = end, y = 40, xend = start, yend = 40), colour = "grey", alpha=1, size=0.3 , inherit.aes = FALSE ) +
  geom_segment(data=grid_data, aes(x = end, y = 20, xend = start, yend = 20), colour = "grey", alpha=1, size=0.3 , inherit.aes = FALSE ) +
  
  # Add text showing the value of each 100/75/50/25 lines
  annotate("text", x = rep(max(data$id),4), y = c(20, 40, 60, 80), label = c("20", "40", "60", "80") , color="grey", size=3 , angle=0, fontface="bold", hjust=1) +
  
  geom_bar(aes(x=as.factor(id), y=value, fill=group), stat="identity", alpha=0.5) +
  ylim(-100,120) +
  theme_minimal() +
  theme(
    legend.position = "none",
    axis.text = element_blank(),
    axis.title = element_blank(),
    panel.grid = element_blank(),
    plot.margin = unit(rep(-1,4), "cm") 
  ) +
  coord_polar() + 
  geom_text(data=label_data, aes(x=id, y=value+10, label=individual, hjust=hjust), color="black", fontface="bold",alpha=0.6, size=2.5, angle= label_data$angle, inherit.aes = FALSE ) +
  
  # Add base line information
  geom_segment(data=base_data, aes(x = start, y = -5, xend = end, yend = -5), colour = "black", alpha=0.8, size=0.6 , inherit.aes = FALSE )  +
  geom_text(data=base_data, aes(x = title, y = -18, label=group), hjust=c(1,1,0,0), colour = "black", alpha=0.8, size=3, fontface="bold", inherit.aes = FALSE) +
 annotate("text", x = 0, y = -90, label = "System\n(66)")


#p
#p + title(main="AH HA")
p +  annotate("text", x = 0, y = -90, label = "Service Area ", hjust=1, vjust=-15)

Upset Plots

library(tidyverse)
library(ggplot2)
library(ggupset)
library(PSJHR)

df    <- data.frame(INSTITUTE = FakeDataPOC$INSTITUTE)
df$yr_mo <- paste0(substr(FakeDataPOC$DischargeDt,6,7),"_",substr(FakeDataPOC$DischargeDt,1,4))
df$mo    <- substr(FakeDataPOC$DischargeDt,6,7)
df$yr    <- substr(FakeDataPOC$DischargeDt,1,4)

set.seed(1245) 
df    <- sample_n(df, 5000) 
  


p<-ggplot(df, aes(x=yr_mo)) +
  geom_bar() +
  axis_combmatrix(sep = "_") +
  theme_combmatrix(combmatrix.label.text = element_text(color = "black", size=10),
                   combmatrix.label.make_space = FALSE,
                   plot.margin = unit(c(1.5, 1.5, 1.5, 65), "pt"))
p

## Put together

main_plot <- df %>% ggplot(aes(x=yr_mo)) +
  geom_bar() +
  ggtitle("The title", subtitle = "Volume consitency check by year & month") +
  axis_combmatrix(sep = "_") +
  xlab("Year / Month") +
theme_combmatrix(combmatrix.label.text = element_text(color = "black", size=10),
                 combmatrix.label.make_space = FALSE,
                 combmatrix.label.extra_spacing =  0 ,
                 plot.margin = unit(c(1.5, 1.5, 1.5, 1), "pt"))

side_plot <- df %>% 
  select(mo) %>%
  unnest(cols = mo) %>%
  count(mo) %>%
  mutate(mo = fct_reorder(as.factor(mo), mo, .desc = TRUE)) %>%
  ggplot(aes(y = n, x = mo)) +
  geom_col() +
  coord_flip() +
  scale_y_reverse() +
  xlab("") + ylab("") +
  theme(axis.ticks.y = element_blank()) # +
#  theme(axis.ticks.y = element_blank(), axis.text.y = element_blank())

table(df$yr, df$mo)
##       
##         01  02  03  04  05  06  07  08  09  10  11  12
##   2017 226 201 210 208 206 202 224 202 202 207 222 213
##   2018 203 182 194 209 225 197 196 226 221 206 199 219
test <- chisq.test(table(df$yr, df$mo))
text1 = paste("X-squared = ",round(test$statistic,3),"\ndf = ",test$parameter, "\np-value = ",round(test$p.value,4))

hold<- ggplot() +
  xlim(1,100) + ylim(1,100) +
 # annotate("text", x = 95, y = 80, size=3.5, label = "Test:", hjust=1, vjust=1, fontface =2,colour = "darkgrey") +
  annotate("text", x = 95, y = 70, size=3.5, label = text1, hjust=1, vjust=1, colour = "darkgrey") + 
  theme_void()

p<-cowplot::plot_grid(
  #cowplot::plot_grid(NULL, side_plot + theme(plot.margin = unit(c(-15, -20, 9, 1), "pt")), ncol = 1, rel_heights = c(1.6, 1)),
  cowplot::plot_grid(hold, side_plot + theme(plot.margin = unit(c(-15, -20, 9, 1), "pt")), ncol = 1, rel_heights = c(1.6, 1)),
  main_plot, nrow = 1, rel_widths = c(1, 3.5)
)

p

Customize ggplot text

#https://www.youtube.com/watch?v=TUKV7Xk1218&list=PL7D2RMSmRO9JOvPC1gbA8Mc3azvSfm8Vv&index=14
library(ggplot2)
library(ggtext)
p1 <- ggplot(mtcars) + 
  geom_point(aes(mpg, disp)) + 
  ggtitle('Plot 1')

p1 +
  labs(title="<strong><span style='color:#ff8c00'>This</span></strong> and <strong><span style='color:red'>That</span></strong>: Some more text"
       ) +
  theme(plot.title = element_markdown(), legend.position= "none")

Data Table (DT)

cars %>%  DT::  datatable(extensions = 'Buttons',
                            caption = 'Table 1. the title',
            options = list(dom = 'Bt, tp',
                           buttons = c('copy', 'csv', 'excel'),
                           lengthMenu = list(c(10,25,50,-1),
                                             c(10,25,50,"All"))))

Animation

# Charge libraries:
library(ggplot2)
library(gganimate)


#####################
# https://www.datanovia.com/en/blog/gganimate-how-to-create-plots-with-beautiful-animation-in-r/
# https://ugoproto.github.io/ugo_r_doc/pdf/gganimate.pdf
# https://theanlim.rbind.io/post/gganimate-animations-with-ggplot2/
# https://easings.net/en
# https://goodekat.github.io/presentations/2019-isugg-gganimate-spooky/slides.html#56
#########################
df2 <- PSJHR::FakeDataPOC %>%
  filter(COHORT=='CABG-EMR') %>%
  #mutate(ym = as.Date(paste0(substr(DischargeDt,1,4),'-',substr(DischargeDt,6,7),'-01'), "%y%m")) %>%
  mutate(year =substr(DischargeDt,1,4),
         month=substr(DischargeDt,6,7)) %>%
  mutate(ym =as.Date(paste(year,'01', month, sep = "-"),format = "%Y-%d-%m")) %>%
  select(REGION_ABBR, IP.Mortality.Numerator, IP.Mortality.Denominator, IP.LOS.Numerator,ym)%>%
  group_by(REGION_ABBR, ym)%>%
  summarize(Mortality_rate = sum(IP.Mortality.Numerator, na.rm=TRUE)/sum(IP.Mortality.Denominator, na.rm=TRUE),
            n = n(),
            IP.LOS.Numerator= mean(IP.LOS.Numerator, na.rm=TRUE))
## `summarise()` has grouped output by 'REGION_ABBR'. You can override using the
## `.groups` argument.
a <- df2 %>%  as.data.frame() %>%
ggplot( aes(IP.LOS.Numerator, Mortality_rate,  size = n, color = REGION_ABBR )) +
  geom_point() +
  #scale_x_log10() +
  theme_bw() +
  labs(title = 'Month: {substr(frame_time,1,7)}', x = 'LOS', y = 'Mortality Rate') +
  transition_time(ym) +
  enter_fade() +
  exit_fade() +

  shadow_wake(wake_length = 0.1, alpha = FALSE) +
  #ease_aes('linear') +
  # view_follow(fixed_y = TRUE) + #Let the view follow the data in each frame
  ease_aes('cubic-in-out') # Slow start and end for a smoother look
##  SAVE ## 
# anim_save("271-ggplot2-animated-gif-chart-with-gganimate1.gif")           
animate(a,nframes = 100, fps=10, end_pause=30) #, width = 400, height = 600, res = 35)

####### As FACETS ##########
df2 %>%  as.data.frame() %>%
  ggplot( aes(IP.LOS.Numerator, Mortality_rate,  size = n, color = REGION_ABBR )) +
  geom_point(alpha = 0.7, show.legend = FALSE) +
  #scale_x_log10() +
  theme_bw() +
  labs(title = 'Month: {substr(frame_time,1,7)}', x = 'LOS', y = 'Mortality Rate') +
  facet_wrap(~REGION_ABBR) +
  transition_time(ym) +
  enter_fade() +
  exit_fade() +
  shadow_wake(wake_length = 0.2, size = 5, alpha = FALSE, colour = 'grey92') +
  #ease_aes('linear') +
  # view_follow(fixed_y = TRUE) + #Let the view follow the data in each frame
  ease_aes('cubic-in-out') # Slow start and end for a smoother look